% slbrainfuck - substandard lisp brainfuck interpreter
% author: Nicky Nickell <nicky.nickell@gmail.com>

(setq helloworld "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>.")

(de range (start end)
  (cond ((greaterp start end)
         (cond ((eqn start end) (cons end nil))
               (t (cons start (range (sub1 start) end)))))
        (t
         (cond ((eqn start end) (cons end nil))
               (t (cons start (range (add1 start) end)))))))

(de bfseek (bfp from direction for)
  (prog nil
    (mapc 
      (cond ((minusp direction) (range 0 from))
            (t (range from (upbv bfp))))
      (lambda (i) (cond
        ((equal (vector-fetch bfp i) for) (return i)))))))

(de bf (bfp bfi)
  (prog (ptr pc memory bfin bfout bfprog)
    (setq ptr 0)
    (setq pc 0)
    (setq bfout nil)
    % increase memory size as needed
    % i dropped it to 200 so firefox wouldn't complain about recursion depth
    (setq memory (make-vector 200 0))
    (setq bfin (string-to-list bfi))
    (setq bfprog (apply 'vector (append (explode2 bfp) '(nil))))

    (prog (op)
top   (setq op (vector-fetch bfprog pc))
      (cond ((equal op '>) (setq ptr (add1 ptr)))
            ((equal op '<) (setq ptr (sub1 ptr)))
            ((equal op '+) (vector-store memory ptr (add1 (vector-fetch memory ptr))))
            ((equal op '-) (vector-store memory ptr (sub1 (vector-fetch memory ptr))))
            ((equal op '.) (setq bfout (cons (vector-fetch memory ptr) bfout)))
            ((equal op ',) (progn (vector-store memory ptr (car bfin))
                                  (setq bfin (cdr bfin))))
            ((equal op '[) 
             (cond ((zerop (vector-fetch memory ptr)) 
                    (setq pc (bfseek bfprog pc 1 '])))))
            ((equal op ']) 
             (cond ((not (zerop (vector-fetch memory ptr))) 
                    (setq pc (sub1 (bfseek bfprog pc -1 '[))))))
            ((null op) (return nil)))
      (setq pc (add1 pc))
      (go top))
  (return (cond ((null bfout) "")
                (t (apply 'string (reverse bfout)))))))

(de bfeval nil
  (dom-append (dom-get-element-by-id "out") "output: <br>"
    (bf (dom-get-value (dom-get-element-by-id "program"))
        (dom-get-value (dom-get-element-by-id "input"))) "<br>"))

(dom-set-title "slbrainfuck")

(dom-append (dom-get-body) 
  "program: " (dom-create-text '(("id" . "program"))) "<br>"
  "input: " (dom-create-text '(("id" . "input"))) "<br>"
  (dom-create-button "execute" nil '(("onclick" . (bfeval)))) "<br>"
  (dom-create "div" '(("id" . "out"))))

(dom-set-attribute (dom-get-element-by-id "program") "value" helloworld)
